home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlcont.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  29.9 KB  |  1,455 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlcont
  5. * RCS:          $Header: xlcont.c,v 1.6 91/03/24 22:24:27 mayer Exp $
  6. * Description:  xlisp special forms
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 03:37:41 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlcont.c,v 1.6 91/03/24 22:24:27 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* external variables */
  48. extern LVAL xlenv,xlfenv,xldenv,xlvalue;
  49. extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
  50. extern LVAL s_svalue,s_sfunction,s_splist;
  51. extern LVAL s_lambda,s_macro;
  52. extern LVAL s_comma,s_comat;
  53. extern LVAL s_unbound;
  54. extern LVAL true;
  55.  
  56. /* external routines */
  57. extern LVAL makearglist();
  58.  
  59. /* forward declarations */
  60. LOCAL FORWARD LVAL bquote1();    /* NPM: changed this to LOCAL */
  61. LOCAL FORWARD LVAL let();    /* NPM: changed this to LOCAL */
  62. LOCAL FORWARD LVAL flet();    /* NPM: changed this to LOCAL */
  63. LOCAL FORWARD LVAL prog();    /* NPM: changed this to LOCAL */
  64. LOCAL FORWARD LVAL progx();    /* NPM: changed this to LOCAL */
  65. LOCAL FORWARD LVAL doloop();    /* NPM: changed this to LOCAL */
  66. LOCAL FORWARD LVAL evarg();    /* NPM: changed this to LOCAL */
  67. LOCAL FORWARD LVAL match();    /* NPM: changed this to LOCAL */
  68. LOCAL FORWARD LVAL evmatch();    /* NPM: changed this to LOCAL */
  69.  
  70. /* dummy node type for a list */
  71. #define LIST    -1
  72.  
  73. /* xquote - special form 'quote' */
  74. LVAL xquote()
  75. {
  76.     LVAL val;
  77.     val = xlgetarg();
  78.     xllastarg();
  79.     return (val);
  80. }
  81.  
  82. /* xfunction - special form 'function' */
  83. LVAL xfunction()
  84. {
  85.     LVAL val;
  86.  
  87.     /* get the argument */
  88.     val = xlgetarg();
  89.     xllastarg();
  90.  
  91.     /* create a closure for lambda expressions */
  92.     if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
  93.     val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
  94.  
  95.     /* otherwise, get the value of a symbol */
  96.     else if (symbolp(val))
  97.     val = xlgetfunction(val);
  98.  
  99.     /* otherwise, its an error */
  100.     else
  101.     xlerror("not a function",val);
  102.  
  103.     /* return the function */
  104.     return (val);
  105. }
  106.  
  107. /* xbquote - back quote special form */
  108. LVAL xbquote()
  109. {
  110.     LVAL expr;
  111.  
  112.     /* get the expression */
  113.     expr = xlgetarg();
  114.     xllastarg();
  115.  
  116.     /* fill in the template */
  117.     return (bquote1(expr));
  118. }
  119.  
  120. /* bquote1 - back quote helper function */
  121. LOCAL LVAL bquote1(expr)
  122.   LVAL expr;
  123. {
  124.     LVAL val,list,last,new;
  125.  
  126.     /* handle atoms */
  127.     if (atom(expr))
  128.     val = expr;
  129.  
  130.     /* handle (comma <expr>) */
  131.     else if (car(expr) == s_comma) {
  132.     if (atom(cdr(expr)))
  133.         xlfail("bad comma expression");
  134.     val = xleval(car(cdr(expr)));
  135.     }
  136.  
  137.     /* handle ((comma-at <expr>) ... ) */
  138.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  139.     xlstkcheck(2);
  140.     xlsave(list);
  141.     xlsave(val);
  142.     if (atom(cdr(car(expr))))
  143.         xlfail("bad comma-at expression");
  144.     list = xleval(car(cdr(car(expr))));
  145.     for (last = NIL; consp(list); list = cdr(list)) {
  146.         new = consa(car(list));
  147.         if (last)
  148.         rplacd(last,new);
  149.         else
  150.         val = new;
  151.         last = new;
  152.     }
  153.     if (last)
  154.         rplacd(last,bquote1(cdr(expr)));
  155.     else
  156.         val = bquote1(cdr(expr));
  157.     xlpopn(2);
  158.     }
  159.  
  160.     /* handle any other list */
  161.     else {
  162.     xlsave1(val);
  163.     val = consa(NIL);
  164.     rplaca(val,bquote1(car(expr)));
  165.     rplacd(val,bquote1(cdr(expr)));
  166.     xlpop();
  167.     }
  168.  
  169.     /* return the result */
  170.     return (val);
  171. }
  172.  
  173. /* xlambda - special form 'lambda' */
  174. LVAL xlambda()
  175. {
  176.     LVAL fargs,arglist,val;
  177.  
  178.     /* get the formal argument list and function body */
  179.     xlsave1(arglist);
  180.     fargs = xlgalist();
  181.     arglist = makearglist(xlargc,xlargv);
  182.  
  183.     /* create a new function definition */
  184.     val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);
  185.  
  186.     /* restore the stack and return the closure */
  187.     xlpop();
  188.     return (val);
  189. }
  190.  
  191. /* xgetlambda - get the lambda expression associated with a closure */
  192. LVAL xgetlambda()
  193. {
  194.     LVAL closure;
  195.     closure = xlgaclosure();
  196.     return (cons(gettype(closure),
  197.                  cons(getlambda(closure),getbody(closure))));
  198. }
  199.  
  200. /* xsetq - special form 'setq' */
  201. LVAL xsetq()
  202. {
  203.     LVAL sym,val;
  204.  
  205.     /* handle each pair of arguments */
  206.     for (val = NIL; moreargs(); ) {
  207.     sym = xlgasymbol();
  208.     val = xleval(nextarg());
  209.     xlsetvalue(sym,val);
  210.     }
  211.  
  212.     /* return the result value */
  213.     return (val);
  214. }
  215.  
  216. /* xpsetq - special form 'psetq' */
  217. LVAL xpsetq()
  218. {
  219.     LVAL plist,sym,val;
  220.  
  221.     /* protect some pointers */
  222.     xlsave1(plist);
  223.  
  224.     /* handle each pair of arguments */
  225.     for (val = NIL; moreargs(); ) {
  226.     sym = xlgasymbol();
  227.     val = xleval(nextarg());
  228.     plist = cons(cons(sym,val),plist);
  229.     }
  230.  
  231.     /* do parallel sets */
  232.     for (; plist; plist = cdr(plist))
  233.     xlsetvalue(car(car(plist)),cdr(car(plist)));
  234.  
  235.     /* restore the stack */
  236.     xlpop();
  237.  
  238.     /* return the result value */
  239.     return (val);
  240. }
  241.  
  242. /* xsetf - special form 'setf' */
  243. LVAL xsetf()
  244. {
  245.     LVAL place,value;
  246.  
  247.     /* protect some pointers */
  248.     xlsave1(value);
  249.  
  250.     /* handle each pair of arguments */
  251.     while (moreargs()) {
  252.  
  253.     /* get place and value */
  254.     place = xlgetarg();
  255.     value = xleval(nextarg());
  256.  
  257.     /* expand macros in the place form */
  258.     if (consp(place))
  259.         place = xlexpandmacros(place);
  260.     
  261.     /* check the place form */
  262.     if (symbolp(place))
  263.         xlsetvalue(place,value);
  264.     else if (consp(place))
  265.         placeform(place,value);
  266.     else
  267.         xlfail("bad place form");
  268.     }
  269.  
  270.     /* restore the stack */
  271.     xlpop();
  272.  
  273.     /* return the value */
  274.     return (value);
  275. }
  276.  
  277. /* placeform - handle a place form other than a symbol */
  278. #ifdef WINTERP
  279. placeform(place,value)        /* needed by w_resources.c:Wres_GetValues_ArgList_To_Lisp */
  280. #else
  281. LOCAL placeform(place,value)
  282. #endif
  283.   LVAL place,value;
  284. {
  285.     LVAL fun,arg1,arg2;
  286.     int i;
  287.  
  288.     /* check the function name */
  289.     if ((fun = match(SYMBOL,&place)) == s_get) {
  290.     xlstkcheck(2);
  291.     xlsave(arg1);
  292.     xlsave(arg2);
  293.     arg1 = evmatch(SYMBOL,&place);
  294.     arg2 = evmatch(SYMBOL,&place);
  295.     if (place) toomany(place);
  296.     xlputprop(arg1,value,arg2);
  297.     xlpopn(2);
  298.     }
  299.     else if (fun == s_svalue) {
  300.     arg1 = evmatch(SYMBOL,&place);
  301.     if (place) toomany(place);
  302.     setvalue(arg1,value);
  303.     }
  304.     else if (fun == s_sfunction) {
  305.     arg1 = evmatch(SYMBOL,&place);
  306.     if (place) toomany(place);
  307.     setfunction(arg1,value);
  308.     }
  309.     else if (fun == s_splist) {
  310.     arg1 = evmatch(SYMBOL,&place);
  311.     if (place) toomany(place);
  312.     setplist(arg1,value);
  313.     }
  314.     else if (fun == s_car) {
  315.     arg1 = evmatch(CONS,&place);
  316.     if (place) toomany(place);
  317.     rplaca(arg1,value);
  318.     }
  319.     else if (fun == s_cdr) {
  320.     arg1 = evmatch(CONS,&place);
  321.     if (place) toomany(place);
  322.     rplacd(arg1,value);
  323.     }
  324.     else if (fun == s_nth) {
  325.     xlsave1(arg1);
  326.     arg1 = evmatch(FIXNUM,&place);
  327.     arg2 = evmatch(LIST,&place);
  328.     if (place) toomany(place);
  329.     for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
  330.         arg2 = cdr(arg2);
  331.     if (consp(arg2))
  332.         rplaca(arg2,value);
  333.     xlpop();
  334.     }
  335.     else if (fun == s_aref) {
  336.     xlsave1(arg1);
  337.     arg1 = evmatch(VECTOR,&place);
  338.     arg2 = evmatch(FIXNUM,&place); i = (int)getfixnum(arg2);
  339.     if (place) toomany(place);
  340.     if (i < 0 || i >= getsize(arg1))
  341.         xlerror("index out of range",arg2);
  342.     setelement(arg1,i,value);
  343.     xlpop();
  344.     }
  345.     else if (fun = xlgetprop(fun,s_setf))
  346.     setffunction(fun,place,value);
  347.     else
  348.     xlfail("bad place form");
  349. }
  350.  
  351. /* setffunction - call a user defined setf function */
  352. LOCAL setffunction(fun,place,value)
  353.   LVAL fun,place,value;
  354. {
  355.     LVAL *newfp;
  356.     int argc;
  357.  
  358.     /* create the new call frame */
  359.     newfp = xlsp;
  360.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  361.     pusharg(fun);
  362.     pusharg(NIL);
  363.  
  364.     /* push the values of all of the place expressions and the new value */
  365.     for (argc = 1; consp(place); place = cdr(place), ++argc)
  366.     pusharg(xleval(car(place)));
  367.     pusharg(value);
  368.  
  369.     /* insert the argument count and establish the call frame */
  370.     newfp[2] = cvfixnum((FIXTYPE)argc);
  371.     xlfp = newfp;
  372.  
  373.     /* apply the function */
  374.     xlapply(argc);
  375. }
  376.                
  377. /* xdefun - special form 'defun' */
  378. LVAL xdefun()
  379. {
  380.     LVAL sym,fargs,arglist;
  381.  
  382.     /* get the function symbol and formal argument list */
  383.     xlsave1(arglist);
  384.     sym = xlgasymbol();
  385.     fargs = xlgalist();
  386.     arglist = makearglist(xlargc,xlargv);
  387.  
  388.     /* make the symbol point to a new function definition */
  389.     xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
  390.  
  391.     /* restore the stack and return the function symbol */
  392.     xlpop();
  393.     return (sym);
  394. }
  395.  
  396. /* xdefmacro - special form 'defmacro' */
  397. LVAL xdefmacro()
  398. {
  399.     LVAL sym,fargs,arglist;
  400.  
  401.     /* get the function symbol and formal argument list */
  402.     xlsave1(arglist);
  403.     sym = xlgasymbol();
  404.     fargs = xlgalist();
  405.     arglist = makearglist(xlargc,xlargv);
  406.  
  407.     /* make the symbol point to a new function definition */
  408.     xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
  409.  
  410.     /* restore the stack and return the function symbol */
  411.     xlpop();
  412.     return (sym);
  413. }
  414.  
  415. /* xcond - special form 'cond' */
  416. LVAL xcond()
  417. {
  418.     LVAL list,val;
  419.  
  420.     /* find a predicate that is true */
  421.     for (val = NIL; moreargs(); ) {
  422.  
  423.     /* get the next conditional */
  424.     list = nextarg();
  425.  
  426.     /* evaluate the predicate part */
  427.     if (consp(list) && (val = xleval(car(list)))) {
  428.  
  429.         /* evaluate each expression */
  430.         for (list = cdr(list); consp(list); list = cdr(list))
  431.         val = xleval(car(list));
  432.  
  433.         /* exit the loop */
  434.         break;
  435.     }
  436.     }
  437.  
  438.     /* return the value */
  439.     return (val);
  440. }
  441.  
  442. /* xwhen - special form 'when' */
  443. LVAL xwhen()
  444. {
  445.     LVAL val;
  446.  
  447.     /* check the test expression */
  448.     if (val = xleval(xlgetarg()))
  449.     while (moreargs())
  450.         val = xleval(nextarg());
  451.  
  452.     /* return the value */
  453.     return (val);
  454. }
  455.  
  456. /* xunless - special form 'unless' */
  457. LVAL xunless()
  458. {
  459.     LVAL val=NIL;
  460.  
  461.     /* check the test expression */
  462.     if (xleval(xlgetarg()) == NIL)
  463.     while (moreargs())
  464.         val = xleval(nextarg());
  465.  
  466.     /* return the value */
  467.     return (val);
  468. }
  469.  
  470. /* xcase - special form 'case' */
  471. LVAL xcase()
  472. {
  473.     LVAL key,list,cases,val;
  474.  
  475.     /* protect some pointers */
  476.     xlsave1(key);
  477.  
  478.     /* get the key expression */
  479.     key = xleval(nextarg());
  480.  
  481.     /* find a case that matches */
  482.     for (val = NIL; moreargs(); ) {
  483.  
  484.     /* get the next case clause */
  485.     list = nextarg();
  486.  
  487.     /* make sure this is a valid clause */
  488.     if (consp(list)) {
  489.  
  490.         /* compare the key list against the key */
  491.         if ((cases = car(list)) == true ||
  492.                 (listp(cases) && keypresent(key,cases)) ||
  493.                 eql(key,cases)) {
  494.  
  495.         /* evaluate each expression */
  496.         for (list = cdr(list); consp(list); list = cdr(list))
  497.             val = xleval(car(list));
  498.  
  499.         /* exit the loop */
  500.         break;
  501.         }
  502.     }
  503.     else
  504.         xlerror("bad case clause",list);
  505.     }
  506.  
  507.     /* restore the stack */
  508.     xlpop();
  509.  
  510.     /* return the value */
  511.     return (val);
  512. }
  513.  
  514. /* keypresent - check for the presence of a key in a list */
  515. LOCAL int keypresent(key,list)
  516.   LVAL key,list;
  517. {
  518.     for (; consp(list); list = cdr(list))
  519.     if (eql(car(list),key))
  520.         return (TRUE);
  521.     return (FALSE);
  522. }
  523.  
  524. /* xand - special form 'and' */
  525. LVAL xand()
  526. {
  527.     LVAL val;
  528.  
  529.     /* evaluate each argument */
  530.     for (val = true; moreargs(); )
  531.     if ((val = xleval(nextarg())) == NIL)
  532.         break;
  533.  
  534.     /* return the result value */
  535.     return (val);
  536. }
  537.  
  538. /* xor - special form 'or' */
  539. LVAL xor()
  540. {
  541.     LVAL val;
  542.  
  543.     /* evaluate each argument */
  544.     for (val = NIL; moreargs(); )
  545.     if ((val = xleval(nextarg())))
  546.         break;
  547.  
  548.     /* return the result value */
  549.     return (val);
  550. }
  551.  
  552. /* xif - special form 'if' */
  553. LVAL xif()
  554. {
  555.     LVAL testexpr,thenexpr,elseexpr;
  556.  
  557.     /* get the test expression, then clause and else clause */
  558.     testexpr = xlgetarg();
  559.     thenexpr = xlgetarg();
  560.     elseexpr = (moreargs() ? xlgetarg() : NIL);
  561.     xllastarg();
  562.  
  563.     /* evaluate the appropriate clause */
  564.     return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
  565. }
  566.  
  567. /* xlet - special form 'let' */
  568. LVAL xlet()
  569. {
  570.     return (let(TRUE));
  571. }
  572.  
  573. /* xletstar - special form 'let*' */
  574. LVAL xletstar()
  575. {
  576.     return (let(FALSE));
  577. }
  578.  
  579. /* let - common let routine */
  580. LOCAL LVAL let(pflag)
  581.   int pflag;
  582. {
  583.     LVAL newenv,val;
  584.  
  585.     /* protect some pointers */
  586.     xlsave1(newenv);
  587.  
  588.     /* create a new environment frame */
  589.     newenv = xlframe(xlenv);
  590.  
  591.     /* get the list of bindings and bind the symbols */
  592.     if (!pflag) xlenv = newenv;
  593.     dobindings(xlgalist(),newenv);
  594.     if (pflag) xlenv = newenv;
  595.  
  596.     /* execute the code */
  597.     for (val = NIL; moreargs(); )
  598.     val = xleval(nextarg());
  599.  
  600.     /* unbind the arguments */
  601.     xlenv = cdr(xlenv);
  602.  
  603.     /* restore the stack */
  604.     xlpop();
  605.  
  606.     /* return the result */
  607.     return (val);
  608. }
  609.  
  610. /* xflet - built-in function 'flet' */
  611. LVAL xflet()
  612. {
  613.     return (flet(s_lambda,TRUE));
  614. }
  615.  
  616. /* xlabels - built-in function 'labels' */
  617. LVAL xlabels()
  618. {
  619.     return (flet(s_lambda,FALSE));
  620. }
  621.  
  622. /* xmacrolet - built-in function 'macrolet' */
  623. LVAL xmacrolet()
  624. {
  625.     return (flet(s_macro,TRUE));
  626. }
  627.  
  628. /* flet - common flet/labels/macrolet routine */
  629. LOCAL LVAL flet(type,letflag)
  630.   LVAL type; int letflag;
  631. {
  632.     LVAL list,bnd,sym,fargs,val;
  633.  
  634.     /* create a new environment frame */
  635.     xlfenv = xlframe(xlfenv);
  636.  
  637.     /* bind each symbol in the list of bindings */
  638.     for (list = xlgalist(); consp(list); list = cdr(list)) {
  639.  
  640.     /* get the next binding */
  641.     bnd = car(list);
  642.  
  643.     /* get the symbol and the function definition */
  644.     sym = match(SYMBOL,&bnd);
  645.     fargs = match(LIST,&bnd);
  646.     val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));
  647.  
  648.     /* bind the value to the symbol */
  649.     xlfbind(sym,val);
  650.     }
  651.  
  652.     /* execute the code */
  653.     for (val = NIL; moreargs(); )
  654.     val = xleval(nextarg());
  655.  
  656.     /* unbind the arguments */
  657.     xlfenv = cdr(xlfenv);
  658.  
  659.     /* return the result */
  660.     return (val);
  661. }
  662.  
  663. /* xprog - special form 'prog' */
  664. LVAL xprog()
  665. {
  666.     return (prog(TRUE));
  667. }
  668.  
  669. /* xprogstar - special form 'prog*' */
  670. LVAL xprogstar()
  671. {
  672.     return (prog(FALSE));
  673. }
  674.  
  675. /* prog - common prog routine */
  676. LOCAL LVAL prog(pflag)
  677.   int pflag;
  678. {
  679.     LVAL newenv,val;
  680.     CONTEXT cntxt;
  681.  
  682.     /* protect some pointers */
  683.     xlsave1(newenv);
  684.  
  685.     /* create a new environment frame */
  686.     newenv = xlframe(xlenv);
  687.  
  688.     /* establish a new execution context */
  689.     xlbegin(&cntxt,CF_RETURN,NIL);
  690.     if (setjmp(cntxt.c_jmpbuf))
  691.     val = xlvalue;
  692.     else {
  693.  
  694.     /* get the list of bindings and bind the symbols */
  695.     if (!pflag) xlenv = newenv;
  696.     dobindings(xlgalist(),newenv);
  697.     if (pflag) xlenv = newenv;
  698.  
  699.     /* execute the code */
  700.     tagbody();
  701.     val = NIL;
  702.  
  703.     /* unbind the arguments */
  704.     xlenv = cdr(xlenv);
  705.     }
  706.     xlend(&cntxt);
  707.  
  708.     /* restore the stack */
  709.     xlpop();
  710.  
  711.     /* return the result */
  712.     return (val);
  713. }
  714.  
  715. /* xgo - special form 'go' */
  716. LVAL xgo()
  717. {
  718.     LVAL label;
  719.  
  720.     /* get the target label */
  721.     label = xlgetarg();
  722.     xllastarg();
  723.  
  724.     /* transfer to the label */
  725.     xlgo(label);
  726. }
  727.  
  728. /* xreturn - special form 'return' */
  729. LVAL xreturn()
  730. {
  731.     LVAL val;
  732.  
  733.     /* get the return value */
  734.     val = (moreargs() ? xleval(nextarg()) : NIL);
  735.     xllastarg();
  736.  
  737.     /* return from the inner most block */
  738.     xlreturn(NIL,val);
  739. }
  740.  
  741. /* xrtnfrom - special form 'return-from' */
  742. LVAL xrtnfrom()
  743. {
  744.     LVAL name,val;
  745.  
  746.     /* get the return value */
  747.     name = xlgasymbol();
  748.     val = (moreargs() ? xleval(nextarg()) : NIL);
  749.     xllastarg();
  750.  
  751.     /* return from the inner most block */
  752.     xlreturn(name,val);
  753. }
  754.  
  755. /* xprog1 - special form 'prog1' */
  756. LVAL xprog1()
  757. {
  758.     return (progx(1));
  759. }
  760.  
  761. /* xprog2 - special form 'prog2' */
  762. LVAL xprog2()
  763. {
  764.     return (progx(2));
  765. }
  766.  
  767. /* progx - common progx code */
  768. LOCAL LVAL progx(n)
  769.   int n;
  770. {
  771.     LVAL val;
  772.  
  773.     /* protect some pointers */
  774.     xlsave1(val);
  775.  
  776.     /* evaluate the first n expressions */
  777.     while (moreargs() && --n >= 0)
  778.     val = xleval(nextarg());
  779.  
  780.     /* evaluate each remaining argument */
  781.     while (moreargs())
  782.     xleval(nextarg());
  783.  
  784.     /* restore the stack */
  785.     xlpop();
  786.  
  787.     /* return the last test expression value */
  788.     return (val);
  789. }
  790.  
  791. /* xprogn - special form 'progn' */
  792. LVAL xprogn()
  793. {
  794.     LVAL val;
  795.  
  796.     /* evaluate each expression */
  797.     for (val = NIL; moreargs(); )
  798.     val = xleval(nextarg());
  799.  
  800.     /* return the last test expression value */
  801.     return (val);
  802. }
  803.  
  804. /* xprogv - special form 'progv' */
  805. LVAL xprogv()
  806. {
  807.     LVAL olddenv,vars,vals,val;
  808.  
  809.     /* protect some pointers */
  810.     xlstkcheck(2);
  811.     xlsave(vars);
  812.     xlsave(vals);
  813.  
  814.     /* get the list of variables and the list of values */
  815.     vars = xlgalist(); vars = xleval(vars);
  816.     vals = xlgalist(); vals = xleval(vals);
  817.  
  818.     /* bind the values to the variables */
  819.     for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
  820.     if (!symbolp(car(vars)))
  821.         xlerror("expecting a symbol",car(vars));
  822.     if (consp(vals)) {
  823.         xldbind(car(vars),car(vals));
  824.         vals = cdr(vals);
  825.     }
  826.     else
  827.         xldbind(car(vars),s_unbound);
  828.     }
  829.  
  830.     /* evaluate each expression */
  831.     for (val = NIL; moreargs(); )
  832.     val = xleval(nextarg());
  833.  
  834.     /* restore the previous environment and the stack */
  835.     xlunbind(olddenv);
  836.     xlpopn(2);
  837.  
  838.     /* return the last test expression value */
  839.     return (val);
  840. }
  841.  
  842. /* xloop - special form 'loop' */
  843. LVAL xloop()
  844. {
  845.     LVAL *argv,arg,val;
  846.     CONTEXT cntxt;
  847.     int argc;
  848.  
  849.     /* protect some pointers */
  850.     xlsave1(arg);
  851.  
  852.     /* establish a new execution context */
  853.     xlbegin(&cntxt,CF_RETURN,NIL);
  854.     if (setjmp(cntxt.c_jmpbuf))
  855.     val = xlvalue;
  856.     else
  857.     for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
  858.         while (moreargs()) {
  859.         arg = nextarg();
  860.         if (consp(arg))
  861.             xleval(arg);
  862.         }
  863.     xlend(&cntxt);
  864.  
  865.     /* restore the stack */
  866.     xlpop();
  867.  
  868.     /* return the result */
  869.     return (val);
  870. }
  871.  
  872. /* xdo - special form 'do' */
  873. LVAL xdo()
  874. {
  875.     return (doloop(TRUE));
  876. }
  877.  
  878. /* xdostar - special form 'do*' */
  879. LVAL xdostar()
  880. {
  881.     return (doloop(FALSE));
  882. }
  883.  
  884. /* doloop - common do routine */
  885. LOCAL LVAL doloop(pflag)
  886.   int pflag;
  887. {
  888.     LVAL newenv,*argv,blist,clist,test,val;
  889.     CONTEXT cntxt;
  890.     int argc;
  891.  
  892.     /* protect some pointers */
  893.     xlsave1(newenv);
  894.  
  895.     /* get the list of bindings, the exit test and the result forms */
  896.     blist = xlgalist();
  897.     clist = xlgalist();
  898.     test = (consp(clist) ? car(clist) : NIL);
  899.     argv = xlargv;
  900.     argc = xlargc;
  901.  
  902.     /* create a new environment frame */
  903.     newenv = xlframe(xlenv);
  904.  
  905.     /* establish a new execution context */
  906.     xlbegin(&cntxt,CF_RETURN,NIL);
  907.     if (setjmp(cntxt.c_jmpbuf))
  908.     val = xlvalue;
  909.     else {
  910.  
  911.     /* bind the symbols */
  912.     if (!pflag) xlenv = newenv;
  913.     dobindings(blist,newenv);
  914.     if (pflag) xlenv = newenv;
  915.  
  916.     /* execute the loop as long as the test is false */
  917.     for (val = NIL; xleval(test) == NIL; doupdates(blist,pflag)) {
  918.         xlargv = argv;
  919.         xlargc = argc;
  920.         tagbody();
  921.     }
  922.  
  923.     /* evaluate the result expression */
  924.     if (consp(clist))
  925.         for (clist = cdr(clist); consp(clist); clist = cdr(clist))
  926.         val = xleval(car(clist));
  927.  
  928.     /* unbind the arguments */
  929.     xlenv = cdr(xlenv);
  930.     }
  931.     xlend(&cntxt);
  932.  
  933.     /* restore the stack */
  934.     xlpop();
  935.  
  936.     /* return the result */
  937.     return (val);
  938. }
  939.  
  940. /* xdolist - special form 'dolist' */
  941. LVAL xdolist()
  942. {
  943.     LVAL list,*argv,clist,sym,val;
  944.     CONTEXT cntxt;
  945.     int argc;
  946.  
  947.     /* protect some pointers */
  948.     xlsave1(list);
  949.  
  950.     /* get the control list (sym list result-expr) */
  951.     clist = xlgalist();
  952.     sym = match(SYMBOL,&clist);
  953.     list = evmatch(LIST,&clist);
  954.     argv = xlargv;
  955.     argc = xlargc;
  956.  
  957.     /* initialize the local environment */
  958.     xlenv = xlframe(xlenv);
  959.     xlbind(sym,NIL);
  960.  
  961.     /* establish a new execution context */
  962.     xlbegin(&cntxt,CF_RETURN,NIL);
  963.     if (setjmp(cntxt.c_jmpbuf))
  964.     val = xlvalue;
  965.     else {
  966.  
  967.     /* loop through the list */
  968.     for (val = NIL; consp(list); list = cdr(list)) {
  969.  
  970.         /* bind the symbol to the next list element */
  971.         xlsetvalue(sym,car(list));
  972.  
  973.         /* execute the loop body */
  974.         xlargv = argv;
  975.         xlargc = argc;
  976.         tagbody();
  977.     }
  978.  
  979.     /* evaluate the result expression */
  980.     xlsetvalue(sym,NIL);
  981.     val = (consp(clist) ? xleval(car(clist)) : NIL);
  982.  
  983.     /* unbind the arguments */
  984.     xlenv = cdr(xlenv);
  985.     }
  986.     xlend(&cntxt);
  987.  
  988.     /* restore the stack */
  989.     xlpop();
  990.  
  991.     /* return the result */
  992.     return (val);
  993. }
  994.  
  995. /* xdotimes - special form 'dotimes' */
  996. LVAL xdotimes()
  997. {
  998.     LVAL *argv,clist,sym,cnt,val;
  999.     CONTEXT cntxt;
  1000.     int argc,n,i;
  1001.  
  1002.     /* get the control list (sym list result-expr) */
  1003.     clist = xlgalist();
  1004.     sym = match(SYMBOL,&clist);
  1005.     cnt = evmatch(FIXNUM,&clist); n = getfixnum(cnt);
  1006.     argv = xlargv;
  1007.     argc = xlargc;
  1008.  
  1009.     /* initialize the local environment */
  1010.     xlenv = xlframe(xlenv);
  1011.     xlbind(sym,NIL);
  1012.  
  1013.     /* establish a new execution context */
  1014.     xlbegin(&cntxt,CF_RETURN,NIL);
  1015.     if (setjmp(cntxt.c_jmpbuf))
  1016.     val = xlvalue;
  1017.     else {
  1018.  
  1019.     /* loop through for each value from zero to n-1 */
  1020.     for (val = NIL, i = 0; i < n; ++i) {
  1021.  
  1022.         /* bind the symbol to the next list element */
  1023.         xlsetvalue(sym,cvfixnum((FIXTYPE)i));
  1024.  
  1025.         /* execute the loop body */
  1026.         xlargv = argv;
  1027.         xlargc = argc;
  1028.         tagbody();
  1029.     }
  1030.  
  1031.     /* evaluate the result expression */
  1032.     xlsetvalue(sym,cnt);
  1033.     val = (consp(clist) ? xleval(car(clist)) : NIL);
  1034.  
  1035.     /* unbind the arguments */
  1036.     xlenv = cdr(xlenv);
  1037.     }
  1038.     xlend(&cntxt);
  1039.  
  1040.     /* return the result */
  1041.     return (val);
  1042. }
  1043.  
  1044. /* xblock - special form 'block' */
  1045. LVAL xblock()
  1046. {
  1047.     LVAL name,val;
  1048.     CONTEXT cntxt;
  1049.  
  1050.     /* get the block name */
  1051.     name = xlgetarg();
  1052.     if (name && !symbolp(name))
  1053.     xlbadtype(name);
  1054.  
  1055.     /* execute the block */
  1056.     xlbegin(&cntxt,CF_RETURN,name);
  1057.     if (setjmp(cntxt.c_jmpbuf))
  1058.     val = xlvalue;
  1059.     else
  1060.     for (val = NIL; moreargs(); )
  1061.         val = xleval(nextarg());
  1062.     xlend(&cntxt);
  1063.  
  1064.     /* return the value of the last expression */
  1065.     return (val);
  1066. }
  1067.  
  1068. /* xtagbody - special form 'tagbody' */
  1069. LVAL xtagbody()
  1070. {
  1071.     tagbody();
  1072.     return (NIL);
  1073. }
  1074.  
  1075. /* xcatch - special form 'catch' */
  1076. LVAL xcatch()
  1077. {
  1078.     CONTEXT cntxt;
  1079.     LVAL tag,val;
  1080.  
  1081.     /* protect some pointers */
  1082.     xlsave1(tag);
  1083.  
  1084.     /* get the tag */
  1085.     tag = xleval(nextarg());
  1086.  
  1087.     /* establish an execution context */
  1088.     xlbegin(&cntxt,CF_THROW,tag);
  1089.  
  1090.     /* check for 'throw' */
  1091.     if (setjmp(cntxt.c_jmpbuf))
  1092.     val = xlvalue;
  1093.  
  1094.     /* otherwise, evaluate the remainder of the arguments */
  1095.     else {
  1096.     for (val = NIL; moreargs(); )
  1097.         val = xleval(nextarg());
  1098.     }
  1099.     xlend(&cntxt);
  1100.  
  1101.     /* restore the stack */
  1102.     xlpop();
  1103.  
  1104.     /* return the result */
  1105.     return (val);
  1106. }
  1107.  
  1108. /* xthrow - special form 'throw' */
  1109. LVAL xthrow()
  1110. {
  1111.     LVAL tag,val;
  1112.  
  1113.     /* get the tag and value */
  1114.     tag = xleval(nextarg());
  1115.     val = (moreargs() ? xleval(nextarg()) : NIL);
  1116.     xllastarg();
  1117.  
  1118.     /* throw the tag */
  1119.     xlthrow(tag,val);
  1120. }
  1121.  
  1122. /* xunwindprotect - special form 'unwind-protect' */
  1123. LVAL xunwindprotect()
  1124. {
  1125.     extern CONTEXT *xltarget;
  1126.     extern int xlmask;
  1127.     CONTEXT cntxt,*target;
  1128.     int mask,sts;
  1129.     LVAL val;
  1130.  
  1131.     /* protect some pointers */
  1132.     xlsave1(val);
  1133.  
  1134.     /* get the expression to protect */
  1135.     val = xlgetarg();
  1136.  
  1137.     /* evaluate the protected expression */
  1138.     xlbegin(&cntxt,CF_UNWIND,NIL);
  1139.     if (sts = setjmp(cntxt.c_jmpbuf)) {
  1140.     target = xltarget;
  1141.     mask = xlmask;
  1142.     val = xlvalue;
  1143.     }
  1144.     else
  1145.     val = xleval(val);
  1146.     xlend(&cntxt);
  1147.     
  1148.     /* evaluate the cleanup expressions */
  1149.     while (moreargs())
  1150.     xleval(nextarg());
  1151.  
  1152.     /* if unwinding, continue unwinding */
  1153.     if (sts)
  1154.     xljump(target,mask,val);
  1155.  
  1156.     /* restore the stack */
  1157.     xlpop();
  1158.  
  1159.     /* return the value of the protected expression */
  1160.     return (val);
  1161. }
  1162.  
  1163. /* xerrset - special form 'errset' */
  1164. LVAL xerrset()
  1165. {
  1166.     LVAL expr,flag,val;
  1167.     CONTEXT cntxt;
  1168.  
  1169.     /* get the expression and the print flag */
  1170.     expr = xlgetarg();
  1171.     flag = (moreargs() ? xlgetarg() : true);
  1172.     xllastarg();
  1173.  
  1174.     /* establish an execution context */
  1175.     xlbegin(&cntxt,CF_ERROR,flag);
  1176.  
  1177.     /* check for error */
  1178.     if (setjmp(cntxt.c_jmpbuf))
  1179.     val = NIL;
  1180.  
  1181.     /* otherwise, evaluate the expression */
  1182.     else {
  1183.     expr = xleval(expr);
  1184.     val = consa(expr);
  1185.     }
  1186.     xlend(&cntxt);
  1187.  
  1188.     /* return the result */
  1189.     return (val);
  1190. }
  1191.  
  1192. /* xtrace - special form 'trace' */
  1193. LVAL xtrace()
  1194. {
  1195.     LVAL sym,fun,this;
  1196.  
  1197.     /* loop through all of the arguments */
  1198.     sym = xlenter("*TRACELIST*");
  1199.     while (moreargs()) {
  1200.     fun = xlgasymbol();
  1201.  
  1202.     /* check for the function name already being in the list */
  1203.     for (this = getvalue(sym); consp(this); this = cdr(this))
  1204.         if (car(this) == fun)
  1205.         break;
  1206.  
  1207.     /* add the function name to the list */
  1208.     if (null(this))
  1209.         setvalue(sym,cons(fun,getvalue(sym)));
  1210.     }
  1211.     return (getvalue(sym));
  1212. }
  1213.  
  1214. /* xuntrace - special form 'untrace' */
  1215. LVAL xuntrace()
  1216. {
  1217.     LVAL sym,fun,this,last;
  1218.  
  1219.     /* loop through all of the arguments */
  1220.     sym = xlenter("*TRACELIST*");
  1221.     while (moreargs()) {
  1222.     fun = xlgasymbol();
  1223.  
  1224.     /* remove the function name from the list */
  1225.     last = NIL;
  1226.     for (this = getvalue(sym); consp(this); this = cdr(this)) {
  1227.         if (car(this) == fun) {
  1228.         if (last)
  1229.             rplacd(last,cdr(this));
  1230.         else
  1231.             setvalue(sym,cdr(this));
  1232.         break;
  1233.         }
  1234.         last = this;
  1235.     }
  1236.     }
  1237.     return (getvalue(sym));
  1238. }
  1239.  
  1240. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  1241. LOCAL dobindings(list,env)
  1242.   LVAL list,env;
  1243. {
  1244.     LVAL bnd,sym,val;
  1245.  
  1246.     /* protect some pointers */
  1247.     xlsave1(val);
  1248.  
  1249.     /* bind each symbol in the list of bindings */
  1250.     for (; consp(list); list = cdr(list)) {
  1251.  
  1252.     /* get the next binding */
  1253.     bnd = car(list);
  1254.  
  1255.     /* handle a symbol */
  1256.     if (symbolp(bnd)) {
  1257.         sym = bnd;
  1258.         val = NIL;
  1259.     }
  1260.  
  1261.     /* handle a list of the form (symbol expr) */
  1262.     else if (consp(bnd)) {
  1263.         sym = match(SYMBOL,&bnd);
  1264.         val = evarg(&bnd);
  1265.     }
  1266.     else
  1267.         xlfail("bad binding");
  1268.  
  1269.     /* bind the value to the symbol */
  1270.     xlpbind(sym,val,env);
  1271.     }
  1272.  
  1273.     /* restore the stack */
  1274.     xlpop();
  1275. }
  1276.  
  1277. /* doupdates - handle updates for do/do* */
  1278. LOCAL doupdates(list,pflag)
  1279.   LVAL list; int pflag;
  1280. {
  1281.     LVAL plist,bnd,sym,val;
  1282.  
  1283.     /* protect some pointers */
  1284.     xlstkcheck(2);
  1285.     xlsave(plist);
  1286.     xlsave(val);
  1287.  
  1288.     /* bind each symbol in the list of bindings */
  1289.     for (; consp(list); list = cdr(list)) {
  1290.  
  1291.     /* get the next binding */
  1292.     bnd = car(list);
  1293.  
  1294.     /* handle a list of the form (symbol expr) */
  1295.     if (consp(bnd)) {
  1296.         sym = match(SYMBOL,&bnd);
  1297.         bnd = cdr(bnd);
  1298.         if (bnd) {
  1299.         val = evarg(&bnd);
  1300.         if (pflag)
  1301.             plist = cons(cons(sym,val),plist);
  1302.         else
  1303.             xlsetvalue(sym,val);
  1304.         }
  1305.     }
  1306.     }
  1307.  
  1308.     /* set the values for parallel updates */
  1309.     for (; plist; plist = cdr(plist))
  1310.     xlsetvalue(car(car(plist)),cdr(car(plist)));
  1311.  
  1312.     /* restore the stack */
  1313.     xlpopn(2);
  1314. }
  1315.  
  1316. /* tagbody - execute code within a block and tagbody */
  1317. LOCAL tagbody()
  1318. {
  1319.     LVAL *argv,arg;
  1320.     CONTEXT cntxt;
  1321.     int argc;
  1322.  
  1323.     /* establish an execution context */
  1324.     xlbegin(&cntxt,CF_GO,NIL);
  1325.     argc = xlargc;
  1326.     argv = xlargv;
  1327.  
  1328.     /* check for a 'go' */
  1329.     if (setjmp(cntxt.c_jmpbuf)) {
  1330.     cntxt.c_xlargc = argc;
  1331.     cntxt.c_xlargv = argv;
  1332.     }
  1333.  
  1334.     /* execute the body */
  1335.     while (moreargs()) {
  1336.     arg = nextarg();
  1337.     if (consp(arg))
  1338.         xleval(arg);
  1339.     }
  1340.     xlend(&cntxt);
  1341. }
  1342.  
  1343. /* match - get an argument and match its type */
  1344. LOCAL LVAL match(type,pargs)
  1345.   int type; LVAL *pargs;
  1346. {
  1347.     LVAL arg;
  1348.  
  1349.     /* make sure the argument exists */
  1350.     if (!consp(*pargs))
  1351.     toofew(*pargs);
  1352.  
  1353.     /* get the argument value */
  1354.     arg = car(*pargs);
  1355.  
  1356.     /* move the argument pointer ahead */
  1357.     *pargs = cdr(*pargs);
  1358.  
  1359.     /* check its type */
  1360.     if (type == LIST) {
  1361.     if (arg && ntype(arg) != CONS)
  1362.         xlerror("bad argument type",arg);
  1363.     }
  1364.     else {
  1365.     if (arg == NIL || ntype(arg) != type)
  1366.         xlerror("bad argument type",arg);
  1367.     }
  1368.  
  1369.     /* return the argument */
  1370.     return (arg);
  1371. }
  1372.  
  1373. /* evarg - get the next argument and evaluate it */
  1374. LOCAL LVAL evarg(pargs)
  1375.   LVAL *pargs;
  1376. {
  1377.     LVAL arg;
  1378.  
  1379.     /* protect some pointers */
  1380.     xlsave1(arg);
  1381.  
  1382.     /* make sure the argument exists */
  1383.     if (!consp(*pargs))
  1384.     toofew(*pargs);
  1385.  
  1386.     /* get the argument value */
  1387.     arg = car(*pargs);
  1388.  
  1389.     /* move the argument pointer ahead */
  1390.     *pargs = cdr(*pargs);
  1391.  
  1392.     /* evaluate the argument */
  1393.     arg = xleval(arg);
  1394.  
  1395.     /* restore the stack */
  1396.     xlpop();
  1397.  
  1398.     /* return the argument */
  1399.     return (arg);
  1400. }
  1401.  
  1402. /* evmatch - get an evaluated argument and match its type */
  1403. LOCAL LVAL evmatch(type,pargs)
  1404.   int type; LVAL *pargs;
  1405. {
  1406.     LVAL arg;
  1407.  
  1408.     /* protect some pointers */
  1409.     xlsave1(arg);
  1410.  
  1411.     /* make sure the argument exists */
  1412.     if (!consp(*pargs))
  1413.     toofew(*pargs);
  1414.  
  1415.     /* get the argument value */
  1416.     arg = car(*pargs);
  1417.  
  1418.     /* move the argument pointer ahead */
  1419.     *pargs = cdr(*pargs);
  1420.  
  1421.     /* evaluate the argument */
  1422.     arg = xleval(arg);
  1423.  
  1424.     /* check its type */
  1425.     if (type == LIST) {
  1426.     if (arg && ntype(arg) != CONS)
  1427.         xlerror("bad argument type",arg);
  1428.     }
  1429.     else {
  1430.     if (arg == NIL || ntype(arg) != type)
  1431.         xlerror("bad argument type",arg);
  1432.     }
  1433.  
  1434.     /* restore the stack */
  1435.     xlpop();
  1436.  
  1437.     /* return the argument */
  1438.     return (arg);
  1439. }
  1440.  
  1441. /* toofew - too few arguments */
  1442. LOCAL toofew(args)
  1443.   LVAL args;
  1444. {
  1445.     xlerror("too few arguments",args);
  1446. }
  1447.  
  1448. /* toomany - too many arguments */
  1449. LOCAL toomany(args)
  1450.   LVAL args;
  1451. {
  1452.     xlerror("too many arguments",args);
  1453. }
  1454.  
  1455.